home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / pc / GFXFX2.ZIP / LENS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-02-14  |  2.8 KB  |  85 lines
  1.  
  2. program lens; { LENS.PAS }
  3. { Lens effect (Wierd? Yeah!) By Bas van Gaalen,
  4.   If you have a fast computer, try using a transparent sprite... }
  5. uses u_vga,u_ffpcx,u_pal,u_kb;
  6. const
  7.   radius=30; { sphere radius }
  8.   maxpoints=3000; { maximum number of points }
  9.   xs=60; ys=60; { size is two times sphere-radius }
  10.   ptab:array[0..255] of byte=( { parabole table for bounce }
  11.     123,121,119,117,115,114,112,110,108,106,104,103,101,99,97,96,94,92,91,
  12.     89,87,86,84,82,81,79,78,76,75,73,72,70,69,67,66,64,63,62,60,59,58,56,
  13.     55,54,52,51,50,49,48,46,45,44,43,42,41,39,38,37,36,35,34,33,32,31,30,
  14.     29,28,27,26,26,25,24,23,22,21,21,20,19,18,17,17,16,15,15,14,13,13,12,
  15.     12,11,10,10,9,9,8,8,7,7,6,6,5,5,5,4,4,4,3,3,3,2,2,2,2,1,1,1,1,1,1,0,0,
  16.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,2,2,2,2,3,3,3,3,4,4,4,5,5,6,6,
  17.     7,7,7,8,8,9,9,10,11,11,12,12,13,14,14,15,16,16,17,18,19,19,20,21,22,
  18.     23,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,
  19.     46,47,48,49,51,52,53,54,56,57,58,60,61,62,64,65,67,68,69,71,72,74,75,
  20.     77,78,80,82,83,85,86,88,90,91,93,95,96,98,100,102,103,105,107,109,111,
  21.     113,114,116,118,120,122,124,126);
  22. type
  23.   parastruc=array[0..xs-1,0..ys-1] of shortint;
  24. var
  25.   para:parastruc;
  26.   pal:pal_type;
  27.   virscr,bckscr:pointer;
  28. const
  29.   paraptr:pointer=@para;
  30.  
  31. procedure initialize;
  32. const
  33.   step=0.035; { working step-size for a radius of 30 }
  34. var
  35.   alpha,beta:real;
  36.   r,x,y,z:integer;
  37. begin
  38.   writeln('Calculating hemi-sphere data. Can take a few secs...');
  39.   fillchar(para,sizeof(para),0);
  40.   alpha:=pi;
  41.   while alpha>0 do begin
  42.     beta:=pi;
  43.     while beta>0 do begin
  44.       x:=radius+round(radius*cos(alpha)*sin(beta));
  45.       y:=radius+round(0.833*radius*cos(beta));
  46.       z:=round(radius*sin(alpha)*sin(beta));
  47.       para[x,y]:=(radius-z) shr 1;
  48.       beta:=beta-step;
  49.     end;
  50.     alpha:=alpha-step;
  51.   end;
  52. end;
  53.  
  54. { Anyone brainy enough could rewrite this to assembler,
  55.   that would speed up things considerably. }
  56. procedure displaypara(x,y:word);
  57. var p:parastruc; i,j:word;
  58. begin
  59.   for i:=x to x+xs-1 do for j:=y to y+ys-1 do
  60.     mem[seg(virscr^):j*320+i]:=mem[seg(virscr^):(j-para[i-x,j-y])*320+i+para[i-x,j-y]];
  61. end;
  62.  
  63. var di:shortint; i:integer; idx:byte;
  64. begin
  65.   initialize;
  66.   setvideo($13);
  67.   getmem(bckscr,320*200); cls(bckscr,320*200);
  68.   if pcx_load('bots.pcx',bckscr,pal)<>pcx_ok then begin
  69.     setvideo(u_lm); writeln('An error occured: ',pcx_errstr); halt; end;
  70.   setpal(pal);
  71.   displaypic(0,0,bckscr,320,200);
  72.   getmem(virscr,320*200); cls(virscr,320*200);
  73.   i:=30; idx:=128; di:=2;
  74.   repeat
  75.     flip(bckscr,virscr,320*200);
  76.     vretrace;
  77.     displaypara(i,15+ptab[idx]); inc(idx,3);
  78.     inc(i,di); if (i<25) or (i+xs>295) then di:=-di;
  79.     flip(virscr,vidptr,320*200);
  80.   until keypressed;
  81.   freemem(virscr,320*200); freemem(bckscr,320*200);
  82.   clearkeybuf;
  83.   setvideo(u_lm);
  84. end.
  85.